home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / lsp / listlib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-04  |  2.9 KB  |  86 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    listlib.lsp
  6. ;;;;
  7. ;;;;                        list manipulating routines
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12. (export '(union nunion intersection nintersection
  13.           set-difference nset-difference set-exclusive-or nset-exclusive-or
  14.           subsetp))
  15.  
  16. (in-package 'system)
  17.  
  18. (proclaim '(optimize (safety 2) (space 3)))
  19.  
  20. (defun union (list1 list2 &rest rest &key test test-not key)
  21.   (declare (ignore test test-not key))
  22.   (cond ((null list1) list2)
  23.     ((apply #'member1 (car list1) list2 rest)
  24.      (apply #'union (cdr list1) list2 rest))
  25.     (t
  26.      (cons (car list1)
  27.            (apply #'union (cdr list1) list2 rest)))))
  28.  
  29. (defun nunion (list1 list2 &rest rest &key test test-not key)
  30.   (declare (ignore test test-not key))
  31.   (cond ((null list1) list2)
  32.     ((apply #'member1 (car list1) list2 rest)
  33.      (apply #'nunion (cdr list1) list2 rest))
  34.     (t
  35.      (rplacd list1
  36.          (apply #'nunion (cdr list1) list2 rest)))))
  37.  
  38. (defun intersection (list1 list2 &rest rest &key test test-not key)
  39.   (declare (ignore test test-not key))
  40.   (cond ((null list1) nil)
  41.     ((apply #'member1 (car list1) list2 rest)
  42.      (cons (car list1)
  43.            (apply #'intersection (cdr list1) list2 rest)))
  44.     (t (apply #'intersection (cdr list1) list2 rest))))
  45.  
  46. (defun nintersection (list1 list2 &rest rest &key test test-not key)
  47.   (declare (ignore test test-not key))
  48.   (cond ((null list1) nil)
  49.     ((apply #'member1 (car list1) list2 rest)
  50.      (rplacd list1
  51.          (apply #'nintersection (cdr list1) list2 rest)))
  52.     (t (apply #'nintersection (cdr list1) list2 rest))))
  53.  
  54. (defun set-difference (list1 list2 &rest rest &key test test-not key)
  55.   (declare (ignore test test-not key))
  56.   (cond ((null list1) nil)
  57.     ((not (apply #'member1 (car list1) list2 rest))
  58.      (cons (car list1)
  59.            (apply #'set-difference (cdr list1) list2 rest)))
  60.     (t (apply #'set-difference (cdr list1) list2 rest))))
  61.  
  62. (defun nset-difference (list1 list2 &rest rest &key test test-not key)
  63.   (declare (ignore test test-not key))
  64.   (cond ((null list1) nil)
  65.     ((not (apply #'member1 (car list1) list2 rest))
  66.      (rplacd list1
  67.          (apply #'nset-difference (cdr list1) list2 rest)))
  68.     (t (apply #'nset-difference (cdr list1) list2 rest))))
  69.  
  70. (defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)
  71.   (declare (ignore test test-not key))
  72.   (append (apply #'set-difference list1 list2 rest)
  73.       (apply #'set-difference list2 list1 rest)))
  74.  
  75. (defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)
  76.   (declare (ignore test test-not key))
  77.   (nconc (apply #'set-difference list1 list2 rest)
  78.      (apply #'nset-difference list2 list1 rest)))
  79.  
  80. (defun subsetp (list1 list2 &rest rest &key test test-not key)
  81.   (declare (ignore test test-not key))
  82.   (do ((l list1 (cdr l)))
  83.       ((null l) t)
  84.     (if (not (apply #'member1 (car l) list2 rest)) (return nil))))
  85.  
  86.